Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue55/Persist/BDEReg2.pas

Pascal/Delphi Source File | 2000-02-02 | 18.3 KB | 634 lines

unit BDEReg2;
{
Author     : Guy Smith-Ferrier
Date       : February 2000
Description:
This unit is a block copy of the TBDEDesigner, TDBDataSetEditor, TTableEditor,
TQueryEditor and TStoredProcEditor classes in Delphi 5's own BDEReg.PAS. There
have been no changes to this code whatsoever. The reason for creating this new
unit is simply to change the scope of the classes so that they are in the
interface section instead of in the implementation section. This allows the
classes to be inherited from.
}

interface

uses
  BDEReg, DSDesign,
  Report, RSConsts, LibHelp, Dialogs, DBLookup, FileCtrl,
  SysUtils, Classes, Menus, DBTables, DB, DRIntf, LibIntf, DsnDBCst,
  DSAttrS, DSAttrA, DBReg, DbXPlor, BDEConst, GQEDelph, ColnEdit, TblDsgn,
  DsgnIntf, DBEdit, IxEdit, UpdSqlEd, FldLinks, CnColEdt, DRTable,
  CustomModuleEditors,
  ParentageSupport, DsnDB,
  ModelViews, ModelPrimitives, DataModelViews, DataModelSupport;

type
  TMenuItemID = (miSeparator, miRetrieve, miSave, miSaveAs, miAssociate, miUnassociate);

  TBDEDesigner = class(TDSDesigner)
  private
    FTableID: TTableID;
    FQueryDescs: TQueryDescription;
    FMenuArray: array [TMenuItemID] of TMenuItem;
  protected
    procedure AttributeClick(Sender: TObject);
    function QualifyTableName(DatabaseName: string;
      Database: TDatabase; const TableName: string): string;
    function CheckAttribute(Field: TField): Boolean;
    procedure GetTableDesc(var ADatabase, ATable: string);
    procedure GetFieldInfo(Field: TField; var FieldID: TFieldID;
      var AttrID: TAttrID);
    function FindFieldInfo(Field: TField; var FieldID: TFieldID;
      var AttrID: TAttrID): Boolean;
    function RetrieveAttributes(Field: TField): Boolean;
    function SaveAttributes(Field: TField): Boolean;
    function SaveAttributesAs(Field: TField): Boolean;
    function AssociateAttributes(Field: TField): Boolean;
    function UnassociateAttributes(Field: TField): Boolean;
  public
    destructor Destroy; override;
    procedure BeginCreateFields; override;
    function DoCreateField(const FieldName: string; Origin: string): TField; override;
    procedure EndCreateFields; override;
    function GetControlClass(Field: TField): string; override;
    procedure InitializeMenu(Menu: TPopupMenu); override;
    procedure UpdateMenus(Menu: TPopupMenu; EditState: TEditState); override;
  end;

  TDBDataSetEditor = class(TDataSetEditor)
  protected
    function GetDSDesignerClass: TDSDesignerClass; override;
  public
    procedure ExecuteVerb(Index: Integer); override;
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
  end;

  TTableEditor = class(TDBDataSetEditor)
  private
    FActions: TTableDesignActions;
    procedure UpdateActions;
    function IndexToAction(Index: Integer): TTableDesignAction;
  public
    procedure ExecuteVerb(Index: Integer); override;
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
  end;

  TQueryEditor = class(TDBDataSetEditor)
  public
    procedure ExecuteVerb(Index: Integer); override;
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
  end;

  TStoredProcEditor = class(TDBDataSetEditor)
  public
    procedure ExecuteVerb(Index: Integer); override;
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
  end;

implementation

destructor TBDEDesigner.Destroy;
begin
  inherited Destroy;
  if DSDesign.DesignerCount <= 0 then DictionaryDeactivate;
end;

function TBDEDesigner.QualifyTableName(DatabaseName: string;
  Database: TDatabase; const TableName: string): string;
begin
  if not Assigned(Database) then
    Result := QualifyTableNameByName(TDBDataset(Dataset).SessionName,
      DatabaseName, TableName) else
    Result := DrIntf.QualifyTableName(Database, TableName);
end;

procedure TBDEDesigner.GetTableDesc(var ADatabase, ATable: string);
var
  Database: TDatabase;
begin
  ADatabase := '';
  ATable := '';
  if Dataset is TTable then
  begin
    ADatabase := TTable(Dataset).DatabaseName;
    Database := TTable(Dataset).Database;
    ATable := QualifyTableName(ADatabase, Database, TTable(Dataset).TableName);
  end;
end;

function TBDEDesigner.CheckAttribute(Field: TField): Boolean;
var
  FieldID: TFieldID;
  AttrID: TAttrID;
begin
  Result := False;
  if Field.AttributeSet <> '' then Exit;
  FindFieldInfo(Field, FieldID, AttrID);
  if not IsNullID(AttrID) then Exit;
  Result := True;
end;

procedure TBDEDesigner.GetFieldInfo(Field: TField; var FieldID: TFieldID;
  var AttrID: TAttrID);
begin
  if not FindFieldInfo(Field, FieldID, AttrID) then
    raise Exception.CreateResFmt(@SDSFieldNotInDict, [Field.FullName]);
end;

function TBDEDesigner.FindFieldInfo(Field: TField; var FieldID: TFieldID;
  var AttrID: TAttrID): Boolean;
var
  DatabaseName, TableName: string;
begin
  GetTableDesc(Databasename, TableName);
  AttrID := NullAttrID;
  FieldID := FindFieldID(FindTableID(FindDatabaseID(DatabaseName), TableName),
    Field.FieldName);
  if not IsNullID(FieldID) then
    AttrID := GetAttrID(FieldID)
  else if Field.AttributeSet <> '' then
    AttrID := FindAttrID(Field.AttributeSet);
  Result := not IsNullID(FieldID) or not IsNullID(AttrID);
end;

function TBDEDesigner.RetrieveAttributes(Field: TField): Boolean;
var
  FieldID: TFieldID;
  AttrID: TAttrID;
begin
  if FindFieldInfo(Field, FieldID, AttrID) then
  begin
    UpdateField(Field, FieldID, AttrID);
    Field.AttributeSet := GetAttrName(AttrID);
  end;
  Result := True;
end;

function TBDEDesigner.SaveAttributes(Field: TField): Boolean;
var
  FieldID: TFieldID;
  AttrID: TAttrID;
begin
  Result := True;
  GetFieldInfo(Field, FieldID, AttrID);
  if not IsNullID(AttrID) then
    UpdateAttr(Field, FieldID, AttrID)
  else
    Result := SaveAttributesAs(Field);
end;

function TBDEDesigner.SaveAttributesAs(Field: TField): Boolean;
var
  DatabaseName, TableName, AttributeName: string;
  FieldID: TFieldID;
  AttrID: TAttrID;
begin
  GetTableDesc(DatabaseName, TableName);
  GetFieldInfo(Field, FieldID, AttrID);
  Result := SaveAttributesAsDlg(TableName, Field.FieldName, AttributeName, AttrID);
  if Result then NewAttr(Field, FieldID, AttributeName, AttrID);
end;

function TBDEDesigner.AssociateAttributes(Field: TField): Boolean;
var
  FieldID: TFieldID;
  AttrID: TAttrID;
begin
  FindFieldInfo(Field, FieldID, AttrID);
  if GetAssociateAttributes(AttrID, Result) then
  begin
    if not IsNullID(FieldID) then AssociateAttr(AttrID, FieldID);
    UpdateField(Field, FieldID, AttrID);
    Field.AttributeSet := GetAttrName(AttrID);
  end;
end;

function TBDEDesigner.UnassociateAttributes(Field: TField): Boolean;
var
  FieldID: TFieldID;
  AttrID: TAttrID;
begin
  Field.AttributeSet := '';
  FindFieldInfo(Field, FieldID, AttrID);
  if not IsNullID(FieldID) then UnassociateAttr(FieldID);
  Field.AttributeSet := '';
  Result := True;
end;

procedure TBDEDesigner.AttributeClick(Sender: TObject);
var
  MenuID: TMenuItemID;
  Proc: TSelectionProc;
begin
  if Assigned(Sender) and (Sender is TComponent) then
    MenuID := TMenuItemID(TComponent(Sender).Tag) else
    MenuID := miSeparator;
  try
    case MenuID of
      miRetrieve: Proc := RetrieveAttributes;
      miSave: Proc := SaveAttributes;
      miSaveAs: Proc := SaveAttributesAs;
      miAssociate: Proc := AssociateAttributes;
      miUnassociate: Proc := UnassociateAttributes;
    else
      Proc := nil;
    end;
    if Assigned(Proc) then
      FieldsEditor.ForEachSelection(Proc);
  finally
    if MenuID in [miAssociate, miRetrieve] then
      FieldsEditor.Designer.Modified;
  end;
end;

function TBDEDesigner.GetControlClass(Field: TField): string;
var
  FieldID: TFieldID;
  AttrId: TAttrID;
begin
  if Assigned(Field) then
  begin
    FindFieldInfo(Field, FieldID, AttrID);
    Result := DRIntf.GetControlClass(AttrID);
  end else
    Result := '';
  if Result = '' then
    Result := inherited GetControlClass(Field);
end;

procedure TBDEDesigner.BeginCreateFields;
var
  DatabaseName, TableName: string;
begin
  if Dataset is TTable then
  begin
    GetTableDesc(DatabaseName, TableName);
    FTableID := FindTableID(FindDatabaseID(DatabaseName), TableName);
  end
  else
  if Dataset is TQuery then
  begin
    FQueryDescs := TQueryDescription.Create(nil);
    try
      FQueryDescs.Query := TQuery(Dataset);
      FQueryDescs.Open;
    except
      FQueryDescs.Free;
      FQueryDescs := nil;
    end;
  end;
  inherited BeginCreateFields;
end;

procedure TBDEDesigner.EndCreateFields;
begin
  FQueryDescs.Free;
  FQueryDescs := nil;
  FTableID := NullTableId;
  inherited EndCreateFields;
end;

function TBDEDesigner.DoCreateField(const FieldName: string; Origin: string): TField;
var
  FieldID: TFieldID;
  AttrID: TAttrID;
  DatabaseName: string;
  TableName: string;
  FldName: string;

  function NeedsBackslashing(const Name: string): Boolean;
  var
    N: PChar;
  begin
    Result := True;
    N := PChar(Pointer(Name));
    while N^ <> #0 do
      if N^ in ['\','"'] then Exit
      else if N^ in LeadBytes then Inc(N, 2)
      else Inc(N);
    Result := False;
  end;

  function Backslash(const Name: string): string;
  var
    CName: array[0..1024] of Char;
    N, C: PChar;
  begin
    N := PChar(Pointer(Name));
    C := CName;
    while N^ <> #0 do
    begin
      if N^ in ['\', '"'] then
      begin
        C^ := '\';
        Inc(C);
      end;
      C^ := N^;
      if N^ in LeadBytes then
      begin
        Inc(C);
        Inc(N);
        C^ := N^;
      end;
      Inc(C);
      Inc(N);
    end;
    SetString(Result, CName, C - CName);
  end;

  function Delimit(const Name: string): string;
  begin
    Result := Name;
    if NeedsBackslashing(Result) then Result := Backslash(Result);
    if Pos('.', Name) <> 0 then Result := '"' + Result + '"';
  end;

begin
  FieldID := NullFieldID;
  AttrID := NullAttrID;
  if Origin = '' then
  begin
    if DataSet is TTable then
    begin
      FieldID := FindFieldID(FTableID, FieldName);
      AttrID := GetAttrID(FieldID);
      Origin := '';
    end else
    if DataSet is TQuery then
    try
      FQueryDescs.RecNo := DataSet.FieldDefs.Find(FieldName).FieldNo;
      DatabaseName := FQueryDescs['DATABASE']; { Do not localize }
      TableName := FQueryDescs['TABLENAME']; { Do not localize }
      FldName := FQueryDescs['FIELDNAME']; { Do not localize }
      FieldID := FindFieldID(FindTableID(FindDatabaseID(DatabaseName),
        QualifyTableName(DatabaseName, nil, FQueryDescs['TABLENAME'])), { Do not localize }
        FQueryDescs['FIELDNAME']); { Do not localize }
      AttrID := GetAttrID(FieldID);
      Origin := Delimit(TableName) + '.' + Delimit(FldName);
      if (TQuery(Dataset).Database = nil) or
         AnsiSameText(TQuery(Dataset).DatabaseName, DatabaseName) then
        Origin := Delimit(DatabaseName) + '.' + Origin;
    except
      FieldID := NullFieldID;
      AttrID := NullAttrID;
      Origin := '';
    end;
  end;
  Result := inherited DoCreateField(FieldName, Origin);
  try
    if DictionaryActive then UpdateField(Result, FieldID, AttrID);
  except
    Result.Free;
    raise;
  end;
end;

procedure TBDEDesigner.InitializeMenu(Menu: TPopupMenu);
type
  TMenuInfo = record
    Name: string;
    HelpContext: Integer;
    Caption: string;
    ShortCut: string;
    Tag: TMenuItemID;
  end;
const
  AttributeMenus: array[TMenuItemID] of TMenuInfo = (
   (Name: 'N2'; HelpContext: 0; Caption: '-'; ShortCut: ''; Tag: miSeparator), { Do not localize }
   (Name: 'RetrieveItem'; HelpContext: 30138; Caption: SRetrieveAttributes;{ Do not localize }
    ShortCut: 'Ctrl+R'; Tag: miRetrieve),{ Do not localize }
   (Name: 'UpdateItem'; HelpContext: 30139; Caption: SSaveAttributes;{ Do not localize }
    ShortCut: 'Ctrl+S'; Tag: miSave),{ Do not localize }
   (Name: 'SaveAttributesAsItem'; HelpContext: 30140; Caption: SSaveAttributesAs;{ Do not localize }
    ShortCut: 'Ctrl+E'; Tag: miSaveAs),{ Do not localize }
   (Name: 'AssociateItem'; HelpContext: 30141; Caption: SAssociateAttributes;{ Do not localize }
    ShortCut: 'Ctrl+O'; Tag: miAssociate),{ Do not localize }
   (Name: 'Unassociate'; HelpContext: 30142; Caption: SUnassociateAttributes;{ Do not localize }
    ShortCut: 'Ctrl+U'; Tag: miUnassociate){ Do not localize }
  );
var
  i: TMenuItemID;
begin
  FTableID := NullTableID;
  FQueryDescs := nil;
  inherited InitializeMenu(Menu);
  for i := Low(AttributeMenus) to High(AttributeMenus) do
  begin
    FMenuArray[i] := TMenuItem.Create(nil);
    FMenuArray[i].Name := AttributeMenus[i].Name;
    FMenuArray[i].HelpContext := AttributeMenus[i].HelpContext;
    FMenuArray[i].Caption := AttributeMenus[i].Caption;
    if AttributeMenus[i].ShortCut <> '' then
      FMenuArray[i].ShortCut := TextToShortCut(AttributeMenus[i].ShortCut);
    FMenuArray[i].Tag := Integer(AttributeMenus[i].Tag);
    FMenuArray[i].OnClick := AttributeClick;
    Menu.Items.Add(FMenuArray[i]);
  end;
end;

procedure TBDEDesigner.UpdateMenus(Menu: TPopupMenu; EditState: TEditState);
var
  i: TMenuItemID;
  Active: Boolean;
  HasAttributes: Boolean;
  Update: Boolean;
  HasSelection: Boolean;
begin
  inherited UpdateMenus(Menu, EditState);
  HasSelection := esCanCopy in EditState;
  Active := DictionaryActive;
  Update := HasSelection and Active;
  HasAttributes := HasSelection and Update and not FieldsEditor.ForEachSelection(CheckAttribute);
  for i := Low(FMenuArray) to High(FMenuArray) do
    if Assigned(FMenuArray[i]) then
      case i of
        miRetrieve: FMenuArray[i].Enabled := HasSelection and Active;
        miSave: FMenuArray[i].Enabled := HasAttributes;
        miSaveAs: FMenuArray[i].Enabled := HasAttributes or (Update and (DataSet is TTable));
        miAssociate: FMenuArray[i].Enabled := Update;
        miUnassociate: FMenuArray[i].Enabled := HasAttributes;
      end;
end;

function TDBDataSetEditor.GetDSDesignerClass: TDSDesignerClass;
begin
  Result := TBDEDesigner;
end;

procedure TDBDataSetEditor.ExecuteVerb(Index: Integer);
begin
  if Index <= inherited GetVerbCount - 1 then
    inherited ExecuteVerb(Index) else
  begin
    Dec(Index, inherited GetVerbCount);
    case Index of
      0: ExploreDataset(TDBDataset(Component));
    end;
  end;
end;

function TDBDataSetEditor.GetVerb(Index: Integer): string;
begin
  if Index <= inherited GetVerbCount - 1 then
    Result := inherited GetVerb(Index) else
  begin
    Dec(Index, inherited GetVerbCount);
    case Index of
      0: Result := SExplore;
    end;
  end;
end;

function TDBDataSetEditor.GetVerbCount: Integer;
begin
  Result := inherited GetVerbCount + 1;
end;

procedure TQueryEditor.ExecuteVerb(Index: Integer);
var
  Database: TDatabase;
  Query: TQuery;
begin
  if Index < inherited GetVerbCount then
    inherited ExecuteVerb(Index) else
  begin
    Query := Component as TQuery;
    Dec(Index, inherited GetVerbCount);
    case Index of
      0: Query.ExecSQL;
      1:
      if GQELoaded then
      begin
        Database := Query.OpenDatabase;
        try
          BuildQuery(Query);
        finally
          Query.CloseDatabase(Database);
        end;
        if Designer <> nil then Designer.Modified;
      end;
    end;
  end;
end;

function TQueryEditor.GetVerb(Index: Integer): string;
begin
  if Index < inherited GetVerbCount then
    Result := inherited GetVerb(Index) else
  begin
    Dec(Index, inherited GetVerbCount);
    case Index of
      0: Result := SExecute;
      1: if GQELoaded then Result := SGQEVerb;
    end;
  end;
end;

function TQueryEditor.GetVerbCount: Integer;
begin
  Result := inherited GetVerbCount + 1 + Ord(LoadGQE);
end;

procedure TStoredProcEditor.ExecuteVerb(Index: Integer);
begin
  if Index < inherited GetVerbCount then
    inherited ExecuteVerb(Index) else
  begin
    Dec(Index, inherited GetVerbCount);
    if Index = 0 then (Component as TStoredProc).ExecProc;
  end;
end;

function TStoredProcEditor.GetVerb(Index: Integer): string;
begin
  if Index < inherited GetVerbCount then
    Result := inherited GetVerb(Index) else
  begin
    Dec(Index, inherited GetVerbCount);
    if Index = 0 then Result := SExecute;
  end;
end;

function TStoredProcEditor.GetVerbCount: Integer;
begin
  Result := inherited GetVerbCount + 1;
end;

function IsDatabaseOpen(DataSet: TDBDataSet): Boolean;
var
  Session: TSession;
  DB: TDatabase;
begin
  Result := False;
  with DataSet do
  begin
    Session := Sessions.FindSession(SessionName);
    if Session <> nil then
    begin
      DB := Session.FindDatabase(DatabaseName);
      Result := (DB <> nil) and DB.Connected;
    end;
  end;
end;

procedure TTableEditor.UpdateActions;
const
  ExistsActions: array [Boolean] of TTableDesignActions =
    ([tdCreate, tdUpdate], [tdDelete, tdUpdate, tdRename]);
begin
  FActions := [];
  if IsDatabaseOpen(TTable(Component)) then
  try
    FActions := ExistsActions[TTable(Component).Exists];
    if (tdCreate in FActions) and (TTable(Component).FieldDefs.Count = 0) then
      Exclude(FActions, tdCreate);
    if (tdUpdate in FActions) and (TTable(Component).TableName = '') then
      Exclude(FActions, tdUpdate);
  except
  end;
end;

function TTableEditor.IndexToAction(Index: Integer): TTableDesignAction;
begin
  for Result := Low(TTableDesignAction) to High(TTableDesignAction) do
    if Result in FActions then if Index = 0 then Exit else Dec(Index);
  Result := tdCreate; // Error
end;

procedure TTableEditor.ExecuteVerb(Index: Integer);
var
  I: Integer;
begin
  I := inherited GetVerbCount;
  if Index < I then inherited
  else if TableDesigner(TTable(Component), IndexToAction(Index - I)) then
    Designer.Modified;
end;

function TTableEditor.GetVerb(Index: Integer): string;
var
  I: Integer;
begin
  I := inherited GetVerbCount;
  if Index < I then
    Result := inherited GetVerb(Index) else
    Result := TableDesignMenu[IndexToAction(Index - I)];
end;

function TTableEditor.GetVerbCount: Integer;
var
  T: TTableDesignAction;
begin
  Result := inherited GetVerbCount;
  UpdateActions;
  for T := Low(TableDesignMenu) to High(TableDesignMenu) do
    if T in FActions then Inc(Result);
end;

end.